home *** CD-ROM | disk | FTP | other *** search
/ infoROM 17,000 Product Descriptions for Business / infoROM Product Descriptions for Business - ESX Interactive.ISO / argdemos / nexsys / rcmerge.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-06-21  |  11.7 KB  |  387 lines
  1. ; rcmerge
  2. ; merge vector entities into raster by colour with differing brushwidth
  3. ;
  4. ; Derrick Oswald
  5. ; Nexsys Consulting Inc.
  6. ; 44 Douglas Drive
  7. ; Ayr, Ontario
  8. ; N0B 1E0
  9. ; (519) 632-8243
  10. ; (519) 632-8244 FAX
  11. ;
  12. (setq ColourFile "COLOUR.MAP")
  13.  
  14. ; group
  15. ; gets the group value given a group and an associative list
  16. ; parameters:
  17. ;   a - group code, usually INT
  18. ;   b - associative list, LIST
  19. ; returns:
  20. ;   value, could be any type
  21. (defun group ( a b )
  22.   (cdr (assoc a b))) ; take tail of dotted associative list element
  23.  
  24. ; grpget
  25. ; gets the group value given a group and an entity name
  26. ; parameters:
  27. ;   a - group code, usually INT
  28. ;   b - entity name, ENAME
  29. ; returns:
  30. ;   value, could be any type
  31. (defun grpget ( a b )
  32.   (group a (entget b))) ; pass associative list onto group
  33.  
  34. ; makelayercolourlist
  35. ; scan the layer table and make an associative list of (layer . colour)
  36. (defun makelayercolourlist ( / l first)
  37.  
  38.   ; set up
  39.   (setq l ())
  40.   (setq first T)
  41.  
  42.   ; scan table
  43.   (while (setq layer (tblnext "layer" first))
  44.  
  45.     ; add layer name and colour to l
  46.     (setq l (cons (cons (group 2 layer) (abs (group 62 layer))) l))
  47.  
  48.     ; prepare for subsequent call
  49.     (setq first ()))
  50.  
  51.   ; return the list reversed to original order
  52.   (reverse l))
  53.  
  54. ; y-or-n-p
  55. ; a predicate that gets a yes or no answer similar to AutoCAD
  56. ; parameters:
  57. ;   st -  prompt string, the default is tacked on it in angle brackets
  58. ;         by this function, STR
  59. ;   def - the default response,
  60. ;         non-nil - default answer to question is Yes
  61. ;         nil     - default answer to question is No
  62. ;
  63. ; NOTE: example useage is to confirm a deletion
  64. ;       (if (y-or-n-p "Delete it?" ())
  65. ;         (command "erase" (entlast)))
  66. (defun y-or-n-p ( string defaul / answer )
  67.   (initget 0 "Yes No")
  68.   (setq answer (getkword (strcat string " <" (if defaul "Y" "N") "> ")))
  69.   (cond
  70.     ((null answer) defaul)
  71.     ((= answer "Yes"))
  72.     ((= answer "No") ())))
  73.  
  74. ; intget
  75. ; to get an integer with a default
  76. ; parameters:
  77. ;  p - prompt string or NIL, STR
  78. ;  d - default value, INT
  79. (defun intget ( p d / s)
  80.   (if                                            ; did user hit enter or space
  81.     (null
  82.       (setq s
  83.         (getint
  84.           (strcat "\n"
  85.             (if (= (type p) 'STR) p "Integer")   ; if there is a prompt use it
  86.             " <"                                      ;  display default value
  87.             (if (numberp d)
  88.               (itoa (fix d))
  89.               "")
  90.             ">: "))))
  91.     d
  92.     s))
  93.  
  94. ; strget
  95. ; get a string with a default
  96. ; parameters:
  97. ;  p - prompt string or NIL, STR
  98. ;  d - default value, REAL
  99. ;  r - indicates if string can contain spaces or not, T or NIL
  100. ;          T = confirm with <CR>
  101. ;          NIL = up to first <SPACE> OR <CR>
  102. (defun strget(p d r / s)
  103.   (if
  104.     (zerop
  105.       (strlen
  106.         (setq s
  107.           (getstring
  108.             r
  109.             (strcat "\n"
  110.               (if (= (type p) 'STR) p "String")  ; if there is a prompt use it
  111.               " <"                                    ;  display default value
  112.               (if (= (type d) 'STR) d "")
  113.               ">: ")))))
  114.     d
  115.     s))
  116.  
  117. ; list of names for colours
  118. (setq colournames (list
  119.   '(1 . "RED")
  120.   '(2 . "YELLOW")
  121.   '(3 . "GREEN")
  122.   '(4 . "BLUE")
  123.   '(5 . "CYAN")
  124.   '(6 . "MAGENTA")
  125.   '(7 . "WHITE")))
  126.  
  127. ; colourname
  128. ; return the name of the colour
  129. (defun colourname (n / s)
  130.  
  131.   ; look it up
  132.   (setq s (assoc n colournames))
  133.  
  134.   ; cover un-named colours
  135.   (if s
  136.     (setq s (cdr s))
  137.     (setq s ""))
  138.  
  139.   ; return colour
  140.   s)
  141.  
  142. ; savecolours
  143. ; save the colour list to a file
  144. (defun savecolours (l / filename f n)
  145.   (setq filename (strget "File name for saving colour-brushwidth list"
  146.     (if FileName FileName ColourFile) ()))
  147.   ; open the file
  148.   (if (setq f (open filename "w"))
  149.     (progn
  150.       ; echo name
  151.       (princ (strcat "\nSaving file \"" filename "\""))
  152.       ; write each colour
  153.       (foreach n l
  154.         (princ (strcat (itoa (car n)) " " (itoa (cdr n)) "\n") f))
  155.       (close f))
  156.     (princ (strcat "\nCan't open file \"" filename "\"")))
  157.   (princ))
  158.  
  159. ; pos
  160. ; searches for a string in another string
  161. ; parameters:
  162. ;   a - source string, STR
  163. ;   b - test string, STR
  164. ;   c - direction flag, 1 for forward, -1 for backwards, INT
  165. ; returns:
  166. ;   the position of the character in the string if found
  167. ;   NIL if not found
  168. (defun pos ( a b c / d e f g )
  169.   (setq d (strlen a)                    ; size of source and done flag
  170.         e (strlen b))                   ; size of test
  171.   (if (= c 1)                           ; if forward:
  172.     (setq f 1                           ; start
  173.           g (1+ d))                     ; limit
  174.     (setq f d                           ; start
  175.           g 0))                         ; limit
  176.   (while (and d (/= f g))                    ; not found and not end of source
  177.     (if (= b (substr a f e))       ; if test string is at our current position
  178.       (setq d nil)                                                ; reset flag
  179.       (setq f (+ f c))))                                   ; else bump pointer
  180.   (if (not d)                                         ; return position or NIL
  181.     f))
  182.  
  183. ; parse
  184. ; parse the next word from the string
  185. ; parameters:
  186. ;   qstring - a quoted string variable, (QUOTE STR)
  187. ;   delim - delimiter character, STR
  188. ; returns:
  189. ;   the parsed word or NIL if string is empty, STR
  190. ; NOTE: modifies the original string by removing the parsed word and delimiter
  191. ;  qstring, delim, string, count & len must be unique to avoid global conflict
  192. (defun parse ( qstring delim / string count len )
  193.   (setq string (eval qstring))                          ; get a copy of string
  194.   (cond
  195.     ((or (null string) (= string ""))
  196.       (set qstring NIL))                    ; if no characters left return NIL
  197.     ((or (null delim) (= delim "")) "")  ; if nothing asked for return nothing
  198.     (T
  199.       (setq len (strlen delim))
  200.       (while (and (setq count (pos string delim 1)) (= count 1))
  201.         (setq string (substr string (1+ len))))      ; pass leading delimiters
  202.       (set qstring (if count (substr string (+ count len))))     ; rest or nil
  203.       (if count (substr string 1 (1- count)) string)))) ; return part or whole
  204.  
  205. ; restorecolours
  206. ; restore the colour list from a file
  207. (defun restorecolours ( / l f a colour width)
  208.   ; get the file name from the user
  209.   (setq FileName (strget "File name to retrieve" ColourFile ()))
  210.   ; scan for it
  211.   (setq FileName (findfile FileName))
  212.   ; open the file
  213.   (if (setq f (open FileName "r"))
  214.     (progn
  215.       ; echo name
  216.       (princ (strcat "\nReading file \"" FileName "\""))
  217.       ; read each colour
  218.       (while (setq a (read-line f))
  219.         (setq colour (parse 'a " "))
  220.         (setq width (parse 'a " "))
  221.         (setq l (cons (cons (atoi colour) (atoi width)) l)))
  222.       (close f))
  223.     (princ (strcat "\nCan't open file \"" FileName "\"")))
  224.   ; return the list in original order
  225.   (reverse l))
  226.  
  227. ; makecolourbrushwidthlist
  228. ; interactively request brushwidth for colour from the user
  229. (defun makecolourbrushwidthlist (/ filename l i colour n)
  230.  
  231.   ; move to text screen
  232.   (textscr)
  233.  
  234.   (while (null l)
  235.     ; get the existing list or make a new one
  236.     (if colourbrushwidthlist
  237.       (setq l colourbrushwidthlist)
  238.       (progn
  239.         ; ask if we should try to read it from file
  240.         (if (y-or-n-p "\nRetrieve colour-brushwidth list from file?" ())
  241.           (setq l (restorecolours))
  242.           ; else have to make it
  243.           (progn
  244.  
  245.             ; get default brushwidth
  246.             (setq brushwidth (intget "Default brushwidth" 3))
  247.  
  248.             ; make the list
  249.             (setq i 0)
  250.             (setq l ())
  251.             (while (<= i 7)
  252.               (setq l (cons (cons i brushwidth) l))
  253.               (setq i (1+ i)))
  254.             (setq l (reverse l)))))))
  255.  
  256.   ; set up
  257.   (setq colour -1)
  258.  
  259.   ; repeat until the user is happy
  260.   (while (not (zerop colour))
  261.  
  262.     ; increment colour for next round
  263.     (setq colour (1+ colour))
  264.  
  265.     ; print out the colour list
  266.     (princ "\n")
  267.     (foreach n l
  268.       (if (not (zerop (car n)))
  269.         (princ (strcat "Colour " (itoa (car n)) " " (colourname (car n)) " width " (itoa (cdr n)) "\n"))))
  270.  
  271.     ; ask for colour
  272.     (setq colour (intget "Colour number (0 to exit)" colour))
  273.  
  274.     ; if it's not in our list add it
  275.     (if (not (assoc colour l))
  276.       (setq l (reverse (cons (cons colour brushwidth) (reverse l)))))
  277.  
  278.     ; if it's not zero get brushwidth
  279.     (if (not (zerop colour))
  280.       (progn
  281.         (setq brushwidth (intget "Brushwidth" (group colour l)))
  282.         ; replace it in the list
  283.         (setq l (subst (cons colour brushwidth) (assoc colour l) l)))))
  284.  
  285.   ; ask if user wants to save the file
  286.   (if (y-or-n-p "\nSave colour-brushwidth list to disk file?" T)
  287.     (savecolours l))
  288.  
  289.   ; back to graph screen
  290.   (graphscr)
  291.  
  292.   ; return the list
  293.   l)
  294.  
  295. ; c:rcmerge
  296. ; main routine to merge coloured objects
  297. (defun c:rcmerge ()
  298.  
  299.   ; get a layer list
  300.   (setq layercolours (makelayercolourlist))
  301.  
  302.   ; get the image to be merged into
  303.   (if (setq block (rimage))
  304.     (progn
  305.  
  306.       ; get the objects to be merged
  307.       (princ "\nIdentify objects to be merged: ")
  308.       (if (and (setq ss (ssget)) (> (sslength ss) 0))
  309.         (progn
  310.  
  311.           ; get the colour list
  312.           (setq colourbrushwidthlist (makecolourbrushwidthlist))
  313.  
  314.           ; freah line
  315.           (princ "\n")
  316.  
  317.           ; repeat for every colour or until no objects are left to merge
  318.           (setq colour 1)
  319.           (while (and (< colour 255) (> (sslength ss) 0))
  320.  
  321.             ; echo progress
  322.             (princ (strcat "\rColour " (itoa colour)))
  323.  
  324.             ; start with an empty selection set of objects with that colour
  325.             (setq cset (ssadd))
  326.  
  327.             ; for every object in the selection set of objects
  328.             (setq index 0)
  329.             (while (< index (sslength ss))
  330.  
  331.               ; get the entity name...
  332.               (setq e (ssname ss index))
  333.  
  334.               ; ...and a list of it's data
  335.               (setq l (entget e))
  336.  
  337.               ; test explicit colour
  338.               (if (assoc 62 l)
  339.  
  340.                 ; if it's colour is explicitly this colour add it to our list
  341.                 (if (= colour (group 62 l))
  342.                   (ssadd e cset))
  343.  
  344.                 ; or if it's layer is this colour add it to the list
  345.                 (if (= colour (group (group 8 l) layercolours))
  346.                   (ssadd e cset)))
  347.  
  348.               ; increment index and repeat
  349.               (setq index (1+ index)))
  350.  
  351.             ; if there's objects of this colour
  352.             (if (> (sslength cset) 0)
  353.  
  354.               ; merge them in
  355.               (progn
  356.  
  357.                 ; must delete them from further consideration
  358.                 (setq index 0)
  359.                 (while (< index (sslength cset))
  360.                   (ssdel (ssname cset index) ss)
  361.                   (setq index (1+ index)))
  362.  
  363.                 ; get the brushwidth or default
  364.                 (if (assoc colour colourbrushwidthlist)
  365.                   (setq brushwidth (group colour colourbrushwidthlist))
  366.                   (setq brushwidth (group 0 colourbrushwidthlist)))
  367.  
  368.                 ; echo the progress
  369.                 (princ (strcat " has " (itoa (sslength cset)) " entities"))
  370.                 (princ (strcat " merging with width " (itoa brushwidth) "\n"))
  371.  
  372.                 ; merge the entities
  373.                 (rmerge block cset brushwidth)))
  374.  
  375.             ; increment colour and repeat
  376.             (setq colour (1+ colour)))
  377.  
  378.         ; end of (if (ssget)
  379.         )
  380.         (princ "\nNo objects selected"))
  381.  
  382.     ; end of (if (entsel)
  383.     )
  384.     (princ "\nNo raster block picked"))
  385.  
  386.   (princ))
  387.